home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl67.lha / tcl6.7 / tclCmdIL.c < prev    next >
C/C++ Source or Header  |  1993-01-22  |  30KB  |  1,165 lines
  1. /* 
  2.  * tclCmdIL.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I through L.  It contains only commands in the generic core
  7.  *    (i.e. those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright 1987-1991 Regents of the University of California
  10.  * Permission to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose and without
  12.  * fee is hereby granted, provided that the above copyright
  13.  * notice appear in all copies.  The University of California
  14.  * makes no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without
  16.  * express or implied warranty.
  17.  */
  18.  
  19. #ifndef lint
  20. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.89 93/01/22 15:17:42 ouster Exp $ SPRITE (Berkeley)";
  21. #endif
  22.  
  23. #include "tclInt.h"
  24.  
  25. /*
  26.  * Forward declarations for procedures defined in this file:
  27.  */
  28.  
  29. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  30.                 CONST VOID *second));
  31.  
  32. /*
  33.  *----------------------------------------------------------------------
  34.  *
  35.  * Tcl_IfCmd --
  36.  *
  37.  *    This procedure is invoked to process the "if" Tcl command.
  38.  *    See the user documentation for details on what it does.
  39.  *
  40.  * Results:
  41.  *    A standard Tcl result.
  42.  *
  43.  * Side effects:
  44.  *    See the user documentation.
  45.  *
  46.  *----------------------------------------------------------------------
  47.  */
  48.  
  49.     /* ARGSUSED */
  50. int
  51. Tcl_IfCmd(dummy, interp, argc, argv)
  52.     ClientData dummy;            /* Not used. */
  53.     Tcl_Interp *interp;            /* Current interpreter. */
  54.     int argc;                /* Number of arguments. */
  55.     char **argv;            /* Argument strings. */
  56. {
  57.     int i, result, value;
  58.  
  59.     i = 1;
  60.     while (1) {
  61.     /*
  62.      * At this point in the loop, argv and argc refer to an expression
  63.      * to test, either for the main expression or an expression
  64.      * following an "elseif".  The arguments after the expression must
  65.      * be "then" (optional) and a script to execute if the expression is
  66.      * true.
  67.      */
  68.  
  69.     if (i >= argc) {
  70.         Tcl_AppendResult(interp, "wrong # args: no expression after \"",
  71.             argv[i-1], "\" argument", (char *) NULL);
  72.         return TCL_ERROR;
  73.     }
  74.     result = Tcl_ExprBoolean(interp, argv[i], &value);
  75.     if (result != TCL_OK) {
  76.         return result;
  77.     }
  78.     i++;
  79.     if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
  80.         i++;
  81.     }
  82.     if (i >= argc) {
  83.         Tcl_AppendResult(interp, "wrong # args: no script following \"",
  84.             argv[i-1], "\" argument", (char *) NULL);
  85.         return TCL_ERROR;
  86.     }
  87.     if (value) {
  88.         return Tcl_Eval(interp, argv[i], 0, (char **) NULL);
  89.     }
  90.  
  91.     /*
  92.      * The expression evaluated to false.  Skip the command, then
  93.      * see if there is an "else" or "elseif" clause.
  94.      */
  95.  
  96.     i++;
  97.     if (i >= argc) {
  98.         return TCL_OK;
  99.     }
  100.     if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
  101.         i++;
  102.         continue;
  103.     }
  104.     break;
  105.     }
  106.  
  107.     /*
  108.      * Couldn't find a "then" or "elseif" clause to execute.  Check now
  109.      * for an "else" clause.  We know that there's at least one more
  110.      * argument when we get here.
  111.      */
  112.  
  113.     if (strcmp(argv[i], "else") == 0) {
  114.     i++;
  115.     if (i >= argc) {
  116.         Tcl_AppendResult(interp,
  117.             "wrong # args: no script following \"else\" argument",
  118.             (char *) NULL);
  119.         return TCL_ERROR;
  120.     }
  121.     }
  122.     return Tcl_Eval(interp, argv[i], 0, (char **) NULL);
  123. }
  124.  
  125. /*
  126.  *----------------------------------------------------------------------
  127.  *
  128.  * Tcl_IncrCmd --
  129.  *
  130.  *    This procedure is invoked to process the "incr" Tcl command.
  131.  *    See the user documentation for details on what it does.
  132.  *
  133.  * Results:
  134.  *    A standard Tcl result.
  135.  *
  136.  * Side effects:
  137.  *    See the user documentation.
  138.  *
  139.  *----------------------------------------------------------------------
  140.  */
  141.  
  142.     /* ARGSUSED */
  143. int
  144. Tcl_IncrCmd(dummy, interp, argc, argv)
  145.     ClientData dummy;            /* Not used. */
  146.     Tcl_Interp *interp;            /* Current interpreter. */
  147.     int argc;                /* Number of arguments. */
  148.     char **argv;            /* Argument strings. */
  149. {
  150.     int value;
  151.     char *oldString, *result;
  152.     char newString[30];
  153.  
  154.     if ((argc != 2) && (argc != 3)) {
  155.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  156.         " varName ?increment?\"", (char *) NULL);
  157.     return TCL_ERROR;
  158.     }
  159.  
  160.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  161.     if (oldString == NULL) {
  162.     return TCL_ERROR;
  163.     }
  164.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  165.     Tcl_AddErrorInfo(interp,
  166.         "\n    (reading value of variable to increment)");
  167.     return TCL_ERROR;
  168.     }
  169.     if (argc == 2) {
  170.     value += 1;
  171.     } else {
  172.     int increment;
  173.  
  174.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  175.         Tcl_AddErrorInfo(interp,
  176.             "\n    (reading increment)");
  177.         return TCL_ERROR;
  178.     }
  179.     value += increment;
  180.     }
  181.     sprintf(newString, "%d", value);
  182.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  183.     if (result == NULL) {
  184.     return TCL_ERROR;
  185.     }
  186.     interp->result = result;
  187.     return TCL_OK; 
  188. }
  189.  
  190. /*
  191.  *----------------------------------------------------------------------
  192.  *
  193.  * Tcl_InfoCmd --
  194.  *
  195.  *    This procedure is invoked to process the "info" Tcl command.
  196.  *    See the user documentation for details on what it does.
  197.  *
  198.  * Results:
  199.  *    A standard Tcl result.
  200.  *
  201.  * Side effects:
  202.  *    See the user documentation.
  203.  *
  204.  *----------------------------------------------------------------------
  205.  */
  206.  
  207.     /* ARGSUSED */
  208. int
  209. Tcl_InfoCmd(dummy, interp, argc, argv)
  210.     ClientData dummy;            /* Not used. */
  211.     Tcl_Interp *interp;            /* Current interpreter. */
  212.     int argc;                /* Number of arguments. */
  213.     char **argv;            /* Argument strings. */
  214. {
  215.     register Interp *iPtr = (Interp *) interp;
  216.     int length;
  217.     char c;
  218.     Arg *argPtr;
  219.     Proc *procPtr;
  220.     Var *varPtr;
  221.     Command *cmdPtr;
  222.     Tcl_HashEntry *hPtr;
  223.     Tcl_HashSearch search;
  224.  
  225.     if (argc < 2) {
  226.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  227.         " option ?arg arg ...?\"", (char *) NULL);
  228.     return TCL_ERROR;
  229.     }
  230.     c = argv[1][0];
  231.     length = strlen(argv[1]);
  232.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  233.     if (argc != 3) {
  234.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  235.             argv[0], " args procname\"", (char *) NULL);
  236.         return TCL_ERROR;
  237.     }
  238.     procPtr = TclFindProc(iPtr, argv[2]);
  239.     if (procPtr == NULL) {
  240.         infoNoSuchProc:
  241.         Tcl_AppendResult(interp, "\"", argv[2],
  242.             "\" isn't a procedure", (char *) NULL);
  243.         return TCL_ERROR;
  244.     }
  245.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  246.         argPtr = argPtr->nextPtr) {
  247.         Tcl_AppendElement(interp, argPtr->name, 0);
  248.     }
  249.     return TCL_OK;
  250.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  251.     if (argc != 3) {
  252.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  253.             " body procname\"", (char *) NULL);
  254.         return TCL_ERROR;
  255.     }
  256.     procPtr = TclFindProc(iPtr, argv[2]);
  257.     if (procPtr == NULL) {
  258.         goto infoNoSuchProc;
  259.     }
  260.     iPtr->result = procPtr->command;
  261.     return TCL_OK;
  262.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  263.         && (length >= 2)) {
  264.     if (argc != 2) {
  265.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  266.             " cmdcount\"", (char *) NULL);
  267.         return TCL_ERROR;
  268.     }
  269.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  270.     return TCL_OK;
  271.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  272.         && (length >= 4)) {
  273.     if (argc > 3) {
  274.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  275.             " commands [pattern]\"", (char *) NULL);
  276.         return TCL_ERROR;
  277.     }
  278.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  279.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  280.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  281.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  282.         continue;
  283.         }
  284.         Tcl_AppendElement(interp, name, 0);
  285.     }
  286.     return TCL_OK;
  287.     } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
  288.         && (length >= 4)) {
  289.     if (argc != 3) {
  290.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  291.             " complete command\"", (char *) NULL);
  292.         return TCL_ERROR;
  293.     }
  294.     if (Tcl_CommandComplete(argv[2])) {
  295.         interp->result = "1";
  296.     } else {
  297.         interp->result = "0";
  298.     }
  299.     return TCL_OK;
  300.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  301.     if (argc != 5) {
  302.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  303.             argv[0], " default procname arg varname\"",
  304.             (char *) NULL);
  305.         return TCL_ERROR;
  306.     }
  307.     procPtr = TclFindProc(iPtr, argv[2]);
  308.     if (procPtr == NULL) {
  309.         goto infoNoSuchProc;
  310.     }
  311.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  312.         if (argPtr == NULL) {
  313.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  314.             "\" doesn't have an argument \"", argv[3],
  315.             "\"", (char *) NULL);
  316.         return TCL_ERROR;
  317.         }
  318.         if (strcmp(argv[3], argPtr->name) == 0) {
  319.         if (argPtr->defValue != NULL) {
  320.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  321.                 argPtr->defValue, 0) == NULL) {
  322.             defStoreError:
  323.             Tcl_AppendResult(interp,
  324.                 "couldn't store default value in variable \"",
  325.                 argv[4], "\"", (char *) NULL);
  326.             return TCL_ERROR;
  327.             }
  328.             iPtr->result = "1";
  329.         } else {
  330.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  331.                 == NULL) {
  332.             goto defStoreError;
  333.             }
  334.             iPtr->result = "0";
  335.         }
  336.         return TCL_OK;
  337.         }
  338.     }
  339.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  340.     char *p;
  341.     if (argc != 3) {
  342.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  343.             " exists varName\"", (char *) NULL);
  344.         return TCL_ERROR;
  345.     }
  346.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  347.  
  348.     /*
  349.      * The code below handles the special case where the name is for
  350.      * an array:  Tcl_GetVar will reject this since you can't read
  351.      * an array variable without an index.
  352.      */
  353.  
  354.     if (p == NULL) {
  355.         Tcl_HashEntry *hPtr;
  356.         Var *varPtr;
  357.  
  358.         if (strchr(argv[2], '(') != NULL) {
  359.         noVar:
  360.         iPtr->result = "0";
  361.         return TCL_OK;
  362.         }
  363.         if (iPtr->varFramePtr == NULL) {
  364.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  365.         } else {
  366.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  367.         }
  368.         if (hPtr == NULL) {
  369.         goto noVar;
  370.         }
  371.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  372.         if (varPtr->flags & VAR_UPVAR) {
  373.         varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  374.         }
  375.         if (!(varPtr->flags & VAR_ARRAY)) {
  376.         goto noVar;
  377.         }
  378.     }
  379.     iPtr->result = "1";
  380.     return TCL_OK;
  381.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  382.     char *name;
  383.  
  384.     if (argc > 3) {
  385.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  386.             " globals [pattern]\"", (char *) NULL);
  387.         return TCL_ERROR;
  388.     }
  389.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  390.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  391.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  392.         if (varPtr->flags & VAR_UNDEFINED) {
  393.         continue;
  394.         }
  395.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  396.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  397.         continue;
  398.         }
  399.         Tcl_AppendElement(interp, name, 0);
  400.     }
  401.     return TCL_OK;
  402.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  403.         && (length >= 2)) {
  404.     if (argc == 2) {
  405.         if (iPtr->varFramePtr == NULL) {
  406.         iPtr->result = "0";
  407.         } else {
  408.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  409.         }
  410.         return TCL_OK;
  411.     } else if (argc == 3) {
  412.         int level;
  413.         CallFrame *framePtr;
  414.  
  415.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  416.         return TCL_ERROR;
  417.         }
  418.         if (level <= 0) {
  419.         if (iPtr->varFramePtr == NULL) {
  420.             levelError:
  421.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  422.                 "\"", (char *) NULL);
  423.             return TCL_ERROR;
  424.         }
  425.         level += iPtr->varFramePtr->level;
  426.         }
  427.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  428.             framePtr = framePtr->callerVarPtr) {
  429.         if (framePtr->level == level) {
  430.             break;
  431.         }
  432.         }
  433.         if (framePtr == NULL) {
  434.         goto levelError;
  435.         }
  436.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  437.         iPtr->freeProc = (Tcl_FreeProc *) free;
  438.         return TCL_OK;
  439.     }
  440.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  441.         " level [number]\"", (char *) NULL);
  442.     return TCL_ERROR;
  443.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  444.         && (length >= 2)) {
  445.     if (argc != 2) {
  446.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  447.             " library\"", (char *) NULL);
  448.         return TCL_ERROR;
  449.     }
  450.     interp->result = getenv("TCL_LIBRARY");
  451.     if (interp->result == NULL) {
  452. #ifdef TCL_LIBRARY
  453.         interp->result = TCL_LIBRARY;
  454. #else
  455.         interp->result = "there is no Tcl library at this installation";
  456.         return TCL_ERROR;
  457. #endif
  458.     }
  459.     return TCL_OK;
  460.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  461.         && (length >= 2)) {
  462.     char *name;
  463.  
  464.     if (argc > 3) {
  465.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  466.             " locals [pattern]\"", (char *) NULL);
  467.         return TCL_ERROR;
  468.     }
  469.     if (iPtr->varFramePtr == NULL) {
  470.         return TCL_OK;
  471.     }
  472.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  473.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  474.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  475.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  476.         continue;
  477.         }
  478.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  479.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  480.         continue;
  481.         }
  482.         Tcl_AppendElement(interp, name, 0);
  483.     }
  484.     return TCL_OK;
  485.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
  486.     if (argc > 3) {
  487.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  488.             " procs [pattern]\"", (char *) NULL);
  489.         return TCL_ERROR;
  490.     }
  491.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  492.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  493.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  494.  
  495.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  496.         if (!TclIsProc(cmdPtr)) {
  497.         continue;
  498.         }
  499.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  500.         continue;
  501.         }
  502.         Tcl_AppendElement(interp, name, 0);
  503.     }
  504.     return TCL_OK;
  505.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  506.     if (argc != 2) {
  507.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  508.             argv[0], " script\"", (char *) NULL);
  509.         return TCL_ERROR;
  510.     }
  511.     if (iPtr->scriptFile != NULL) {
  512.         interp->result = iPtr->scriptFile;
  513.     }
  514.     return TCL_OK;
  515.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  516.     if (argc != 2) {
  517.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  518.             argv[0], " tclversion\"", (char *) NULL);
  519.         return TCL_ERROR;
  520.     }
  521.  
  522.     /*
  523.      * Note:  TCL_VERSION below is expected to be set with a "-D"
  524.      * switch in the Makefile.
  525.      */
  526.  
  527.     strcpy(iPtr->result, TCL_VERSION);
  528.     return TCL_OK;
  529.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  530.     Tcl_HashTable *tablePtr;
  531.     char *name;
  532.  
  533.     if (argc > 3) {
  534.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  535.             argv[0], " vars [pattern]\"", (char *) NULL);
  536.         return TCL_ERROR;
  537.     }
  538.     if (iPtr->varFramePtr == NULL) {
  539.         tablePtr = &iPtr->globalTable;
  540.     } else {
  541.         tablePtr = &iPtr->varFramePtr->varTable;
  542.     }
  543.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  544.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  545.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  546.         if (varPtr->flags & VAR_UNDEFINED) {
  547.         continue;
  548.         }
  549.         name = Tcl_GetHashKey(tablePtr, hPtr);
  550.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  551.         continue;
  552.         }
  553.         Tcl_AppendElement(interp, name, 0);
  554.     }
  555.     return TCL_OK;
  556.     } else {
  557.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  558.         "\": should be args, body, cmdcount, commands, ",
  559.         "complete, default, ",
  560.         "exists, globals, level, library, locals, procs, ",
  561.         "script, tclversion, or vars",
  562.         (char *) NULL);
  563.     return TCL_ERROR;
  564.     }
  565. }
  566.  
  567. /*
  568.  *----------------------------------------------------------------------
  569.  *
  570.  * Tcl_JoinCmd --
  571.  *
  572.  *    This procedure is invoked to process the "join" Tcl command.
  573.  *    See the user documentation for details on what it does.
  574.  *
  575.  * Results:
  576.  *    A standard Tcl result.
  577.  *
  578.  * Side effects:
  579.  *    See the user documentation.
  580.  *
  581.  *----------------------------------------------------------------------
  582.  */
  583.  
  584.     /* ARGSUSED */
  585. int
  586. Tcl_JoinCmd(dummy, interp, argc, argv)
  587.     ClientData dummy;            /* Not used. */
  588.     Tcl_Interp *interp;            /* Current interpreter. */
  589.     int argc;                /* Number of arguments. */
  590.     char **argv;            /* Argument strings. */
  591. {
  592.     char *joinString;
  593.     char **listArgv;
  594.     int listArgc, i;
  595.  
  596.     if (argc == 2) {
  597.     joinString = " ";
  598.     } else if (argc == 3) {
  599.     joinString = argv[2];
  600.     } else {
  601.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  602.         " list ?joinString?\"", (char *) NULL);
  603.     return TCL_ERROR;
  604.     }
  605.  
  606.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  607.     return TCL_ERROR;
  608.     }
  609.     for (i = 0; i < listArgc; i++) {
  610.     if (i == 0) {
  611.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  612.     } else  {
  613.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  614.     }
  615.     }
  616.     ckfree((char *) listArgv);
  617.     return TCL_OK;
  618. }
  619.  
  620. /*
  621.  *----------------------------------------------------------------------
  622.  *
  623.  * Tcl_LindexCmd --
  624.  *
  625.  *    This procedure is invoked to process the "lindex" Tcl command.
  626.  *    See the user documentation for details on what it does.
  627.  *
  628.  * Results:
  629.  *    A standard Tcl result.
  630.  *
  631.  * Side effects:
  632.  *    See the user documentation.
  633.  *
  634.  *----------------------------------------------------------------------
  635.  */
  636.  
  637.     /* ARGSUSED */
  638. int
  639. Tcl_LindexCmd(dummy, interp, argc, argv)
  640.     ClientData dummy;            /* Not used. */
  641.     Tcl_Interp *interp;            /* Current interpreter. */
  642.     int argc;                /* Number of arguments. */
  643.     char **argv;            /* Argument strings. */
  644. {
  645.     char *p, *element;
  646.     int index, size, parenthesized, result;
  647.  
  648.     if (argc != 3) {
  649.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  650.         " list index\"", (char *) NULL);
  651.     return TCL_ERROR;
  652.     }
  653.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  654.     return TCL_ERROR;
  655.     }
  656.     if (index < 0) {
  657.     return TCL_OK;
  658.     }
  659.     for (p = argv[1] ; index >= 0; index--) {
  660.     result = TclFindElement(interp, p, &element, &p, &size,
  661.         &parenthesized);
  662.     if (result != TCL_OK) {
  663.         return result;
  664.     }
  665.     }
  666.     if (size == 0) {
  667.     return TCL_OK;
  668.     }
  669.     if (size >= TCL_RESULT_SIZE) {
  670.     interp->result = (char *) ckalloc((unsigned) size+1);
  671.     interp->freeProc = (Tcl_FreeProc *) free;
  672.     }
  673.     if (parenthesized) {
  674.     memcpy((VOID *) interp->result, (VOID *) element, size);
  675.     interp->result[size] = 0;
  676.     } else {
  677.     TclCopyAndCollapse(size, element, interp->result);
  678.     }
  679.     return TCL_OK;
  680. }
  681.  
  682. /*
  683.  *----------------------------------------------------------------------
  684.  *
  685.  * Tcl_LinsertCmd --
  686.  *
  687.  *    This procedure is invoked to process the "linsert" Tcl command.
  688.  *    See the user documentation for details on what it does.
  689.  *
  690.  * Results:
  691.  *    A standard Tcl result.
  692.  *
  693.  * Side effects:
  694.  *    See the user documentation.
  695.  *
  696.  *----------------------------------------------------------------------
  697.  */
  698.  
  699.     /* ARGSUSED */
  700. int
  701. Tcl_LinsertCmd(dummy, interp, argc, argv)
  702.     ClientData dummy;            /* Not used. */
  703.     Tcl_Interp *interp;            /* Current interpreter. */
  704.     int argc;                /* Number of arguments. */
  705.     char **argv;            /* Argument strings. */
  706. {
  707.     char *p, *element, savedChar;
  708.     int i, index, count, result, size;
  709.  
  710.     if (argc < 4) {
  711.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  712.         " list index element ?element ...?\"", (char *) NULL);
  713.     return TCL_ERROR;
  714.     }
  715.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  716.     return TCL_ERROR;
  717.     }
  718.  
  719.     /*
  720.      * Skip over the first "index" elements of the list, then add
  721.      * all of those elements to the result.
  722.      */
  723.  
  724.     size = 0;
  725.     element = argv[1];
  726.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  727.     result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
  728.     if (result != TCL_OK) {
  729.         return result;
  730.     }
  731.     }
  732.     if (*p == 0) {
  733.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  734.     } else {
  735.     char *end;
  736.  
  737.     end = element+size;
  738.     if (element != argv[1]) {
  739.         while ((*end != 0) && !isspace(*end)) {
  740.         end++;
  741.         }
  742.     }
  743.     savedChar = *end;
  744.     *end = 0;
  745.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  746.     *end = savedChar;
  747.     }
  748.  
  749.     /*
  750.      * Add the new list elements.
  751.      */
  752.  
  753.     for (i = 3; i < argc; i++) {
  754.     Tcl_AppendElement(interp, argv[i], 0);
  755.     }
  756.  
  757.     /*
  758.      * Append the remainder of the original list.
  759.      */
  760.  
  761.     if (*p != 0) {
  762.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  763.     }
  764.     return TCL_OK;
  765. }
  766.  
  767. /*
  768.  *----------------------------------------------------------------------
  769.  *
  770.  * Tcl_ListCmd --
  771.  *
  772.  *    This procedure is invoked to process the "list" Tcl command.
  773.  *    See the user documentation for details on what it does.
  774.  *
  775.  * Results:
  776.  *    A standard Tcl result.
  777.  *
  778.  * Side effects:
  779.  *    See the user documentation.
  780.  *
  781.  *----------------------------------------------------------------------
  782.  */
  783.  
  784.     /* ARGSUSED */
  785. int
  786. Tcl_ListCmd(dummy, interp, argc, argv)
  787.     ClientData dummy;            /* Not used. */
  788.     Tcl_Interp *interp;            /* Current interpreter. */
  789.     int argc;                /* Number of arguments. */
  790.     char **argv;            /* Argument strings. */
  791. {
  792.     if (argc < 2) {
  793.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  794.         " arg ?arg ...?\"", (char *) NULL);
  795.     return TCL_ERROR;
  796.     }
  797.     interp->result = Tcl_Merge(argc-1, argv+1);
  798.     interp->freeProc = (Tcl_FreeProc *) free;
  799.     return TCL_OK;
  800. }
  801.  
  802. /*
  803.  *----------------------------------------------------------------------
  804.  *
  805.  * Tcl_LlengthCmd --
  806.  *
  807.  *    This procedure is invoked to process the "llength" Tcl command.
  808.  *    See the user documentation for details on what it does.
  809.  *
  810.  * Results:
  811.  *    A standard Tcl result.
  812.  *
  813.  * Side effects:
  814.  *    See the user documentation.
  815.  *
  816.  *----------------------------------------------------------------------
  817.  */
  818.  
  819.     /* ARGSUSED */
  820. int
  821. Tcl_LlengthCmd(dummy, interp, argc, argv)
  822.     ClientData dummy;            /* Not used. */
  823.     Tcl_Interp *interp;            /* Current interpreter. */
  824.     int argc;                /* Number of arguments. */
  825.     char **argv;            /* Argument strings. */
  826. {
  827.     int count, result;
  828.     char *element, *p;
  829.  
  830.     if (argc != 2) {
  831.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  832.         " list\"", (char *) NULL);
  833.     return TCL_ERROR;
  834.     }
  835.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  836.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  837.         (int *) NULL);
  838.     if (result != TCL_OK) {
  839.         return result;
  840.     }
  841.     if (*element == 0) {
  842.         break;
  843.     }
  844.     }
  845.     sprintf(interp->result, "%d", count);
  846.     return TCL_OK;
  847. }
  848.  
  849. /*
  850.  *----------------------------------------------------------------------
  851.  *
  852.  * Tcl_LrangeCmd --
  853.  *
  854.  *    This procedure is invoked to process the "lrange" Tcl command.
  855.  *    See the user documentation for details on what it does.
  856.  *
  857.  * Results:
  858.  *    A standard Tcl result.
  859.  *
  860.  * Side effects:
  861.  *    See the user documentation.
  862.  *
  863.  *----------------------------------------------------------------------
  864.  */
  865.  
  866.     /* ARGSUSED */
  867. int
  868. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  869.     ClientData notUsed;            /* Not used. */
  870.     Tcl_Interp *interp;            /* Current interpreter. */
  871.     int argc;                /* Number of arguments. */
  872.     char **argv;            /* Argument strings. */
  873. {
  874.     int first, last, result;
  875.     char *begin, *end, c, *dummy;
  876.     int count;
  877.  
  878.     if (argc != 4) {
  879.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  880.         " list first last\"", (char *) NULL);
  881.     return TCL_ERROR;
  882.     }
  883.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  884.     return TCL_ERROR;
  885.     }
  886.     if (first < 0) {
  887.     first = 0;
  888.     }
  889.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  890.     last = 1000000;
  891.     } else {
  892.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  893.         Tcl_ResetResult(interp);
  894.         Tcl_AppendResult(interp,
  895.             "expected integer or \"end\" but got \"",
  896.             argv[3], "\"", (char *) NULL);
  897.         return TCL_ERROR;
  898.     }
  899.     }
  900.     if (first > last) {
  901.     return TCL_OK;
  902.     }
  903.  
  904.     /*
  905.      * Extract a range of fields.
  906.      */
  907.  
  908.     for (count = 0, begin = argv[1]; count < first; count++) {
  909.     result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
  910.         (int *) NULL);
  911.     if (result != TCL_OK) {
  912.         return result;
  913.     }
  914.     if (*begin == 0) {
  915.         break;
  916.     }
  917.     }
  918.     for (count = first, end = begin; (count <= last) && (*end != 0);
  919.         count++) {
  920.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  921.         (int *) NULL);
  922.     if (result != TCL_OK) {
  923.         return result;
  924.     }
  925.     }
  926.  
  927.     /*
  928.      * Chop off trailing spaces.
  929.      */
  930.  
  931.     while (isspace(end[-1])) {
  932.     end--;
  933.     }
  934.     c = *end;
  935.     *end = 0;
  936.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  937.     *end = c;
  938.     return TCL_OK;
  939. }
  940.  
  941. /*
  942.  *----------------------------------------------------------------------
  943.  *
  944.  * Tcl_LreplaceCmd --
  945.  *
  946.  *    This procedure is invoked to process the "lreplace" Tcl command.
  947.  *    See the user documentation for details on what it does.
  948.  *
  949.  * Results:
  950.  *    A standard Tcl result.
  951.  *
  952.  * Side effects:
  953.  *    See the user documentation.
  954.  *
  955.  *----------------------------------------------------------------------
  956.  */
  957.  
  958.     /* ARGSUSED */
  959. int
  960. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  961.     ClientData notUsed;            /* Not used. */
  962.     Tcl_Interp *interp;            /* Current interpreter. */
  963.     int argc;                /* Number of arguments. */
  964.     char **argv;            /* Argument strings. */
  965. {
  966.     char *p1, *p2, *element, savedChar, *dummy;
  967.     int i, first, last, count, result, size;
  968.  
  969.     if (argc < 4) {
  970.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  971.         " list first last ?element element ...?\"", (char *) NULL);
  972.     return TCL_ERROR;
  973.     }
  974.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  975.     return TCL_ERROR;
  976.     }
  977.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  978.     return TCL_ERROR;
  979.     }
  980.     if (first < 0) {
  981.     first = 0;
  982.     }
  983.     if (last < 0) {
  984.     last = 0;
  985.     }
  986.     if (first > last) {
  987.     Tcl_AppendResult(interp, "first index must not be greater than second",
  988.         (char *) NULL);
  989.     return TCL_ERROR;
  990.     }
  991.  
  992.     /*
  993.      * Skip over the elements of the list before "first".
  994.      */
  995.  
  996.     size = 0;
  997.     element = argv[1];
  998.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  999.     result = TclFindElement(interp, p1, &element, &p1, &size,
  1000.         (int *) NULL);
  1001.     if (result != TCL_OK) {
  1002.         return result;
  1003.     }
  1004.     }
  1005.     if (*p1 == 0) {
  1006.     Tcl_AppendResult(interp, "list doesn't contain element ",
  1007.         argv[2], (char *) NULL);
  1008.     return TCL_ERROR;
  1009.     }
  1010.  
  1011.     /*
  1012.      * Skip over the elements of the list up through "last".
  1013.      */
  1014.  
  1015.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  1016.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  1017.         (int *) NULL);
  1018.     if (result != TCL_OK) {
  1019.         return result;
  1020.     }
  1021.     }
  1022.  
  1023.     /*
  1024.      * Add the elements before "first" to the result.  Be sure to
  1025.      * include quote or brace characters that might terminate the
  1026.      * last of these elements.
  1027.      */
  1028.  
  1029.     p1 = element+size;
  1030.     if (element != argv[1]) {
  1031.     while ((*p1 != 0) && !isspace(*p1)) {
  1032.         p1++;
  1033.     }
  1034.     }
  1035.     savedChar = *p1;
  1036.     *p1 = 0;
  1037.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1038.     *p1 = savedChar;
  1039.  
  1040.     /*
  1041.      * Add the new list elements.
  1042.      */
  1043.  
  1044.     for (i = 4; i < argc; i++) {
  1045.     Tcl_AppendElement(interp, argv[i], 0);
  1046.     }
  1047.  
  1048.     /*
  1049.      * Append the remainder of the original list.
  1050.      */
  1051.  
  1052.     if (*p2 != 0) {
  1053.     if (*interp->result == 0) {
  1054.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1055.     } else {
  1056.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1057.     }
  1058.     }
  1059.     return TCL_OK;
  1060. }
  1061.  
  1062. /*
  1063.  *----------------------------------------------------------------------
  1064.  *
  1065.  * Tcl_LsearchCmd --
  1066.  *
  1067.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1068.  *    See the user documentation for details on what it does.
  1069.  *
  1070.  * Results:
  1071.  *    A standard Tcl result.
  1072.  *
  1073.  * Side effects:
  1074.  *    See the user documentation.
  1075.  *
  1076.  *----------------------------------------------------------------------
  1077.  */
  1078.  
  1079.     /* ARGSUSED */
  1080. int
  1081. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1082.     ClientData notUsed;            /* Not used. */
  1083.     Tcl_Interp *interp;            /* Current interpreter. */
  1084.     int argc;                /* Number of arguments. */
  1085.     char **argv;            /* Argument strings. */
  1086. {
  1087.     int listArgc;
  1088.     char **listArgv;
  1089.     int i, match;
  1090.  
  1091.     if (argc != 3) {
  1092.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1093.         " list pattern\"", (char *) NULL);
  1094.     return TCL_ERROR;
  1095.     }
  1096.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1097.     return TCL_ERROR;
  1098.     }
  1099.     match = -1;
  1100.     for (i = 0; i < listArgc; i++) {
  1101.     if (Tcl_StringMatch(listArgv[i], argv[2])) {
  1102.         match = i;
  1103.         break;
  1104.     }
  1105.     }
  1106.     sprintf(interp->result, "%d", match);
  1107.     ckfree((char *) listArgv);
  1108.     return TCL_OK;
  1109. }
  1110.  
  1111. /*
  1112.  *----------------------------------------------------------------------
  1113.  *
  1114.  * Tcl_LsortCmd --
  1115.  *
  1116.  *    This procedure is invoked to process the "lsort" Tcl command.
  1117.  *    See the user documentation for details on what it does.
  1118.  *
  1119.  * Results:
  1120.  *    A standard Tcl result.
  1121.  *
  1122.  * Side effects:
  1123.  *    See the user documentation.
  1124.  *
  1125.  *----------------------------------------------------------------------
  1126.  */
  1127.  
  1128.     /* ARGSUSED */
  1129. int
  1130. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1131.     ClientData notUsed;            /* Not used. */
  1132.     Tcl_Interp *interp;            /* Current interpreter. */
  1133.     int argc;                /* Number of arguments. */
  1134.     char **argv;            /* Argument strings. */
  1135. {
  1136.     int listArgc;
  1137.     char **listArgv;
  1138.  
  1139.     if (argc != 2) {
  1140.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1141.         " list\"", (char *) NULL);
  1142.     return TCL_ERROR;
  1143.     }
  1144.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1145.     return TCL_ERROR;
  1146.     }
  1147.     qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
  1148.     interp->result = Tcl_Merge(listArgc, listArgv);
  1149.     interp->freeProc = (Tcl_FreeProc *) free;
  1150.     ckfree((char *) listArgv);
  1151.     return TCL_OK;
  1152. }
  1153.  
  1154. /*
  1155.  * The procedure below is called back by qsort to determine
  1156.  * the proper ordering between two elements.
  1157.  */
  1158.  
  1159. static int
  1160. SortCompareProc(first, second)
  1161.     CONST VOID *first, *second;        /* Elements to be compared. */
  1162. {
  1163.     return strcmp(*((char **) first), *((char **) second));
  1164. }
  1165.